home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / WINDOWS.S < prev   
Encoding:
Text File  |  1993-10-24  |  13.2 KB  |  377 lines
  1. ; WINDOWS.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Text and Windows Manipulation Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: John Jensen        Date: 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*        Added full-screen, split-screen, text-mode, gc-screen mv*
  19. ;* - Jan 93: Added window-scroll-up/down, window-reverse-text! (mv)    *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23.  
  24. ; The biggest legal size.
  25.  
  26. (define    max-console '(200 . 200))
  27.  
  28. ;    GC-SCREEN put the PCS-STATUS-WINDOW on the last line of CONSOLE
  29.  
  30. (define    (gc-screen)
  31.   (let* ((xy (window-get-position 'console))
  32.          (hl (let ((his-bet (window-get-size 'console)))
  33.                (cons (- (min (car his-bet) (- (car max-console) (car xy))) 1)
  34.                      (min (cdr his-bet) (- (cdr max-console) (cdr xy))))))
  35.          (at (window-get-attribute pcs-status-window 'text-attributes)))
  36.     (window-set-attribute! pcs-status-window 'text-attributes 0)
  37.     (window-clear pcs-status-window)
  38.     (window-set-size! 'console (car hl) (cdr hl))
  39.     (window-set-position! pcs-status-window (+ (car xy) (car hl)) (cdr xy))
  40.     (window-set-size! pcs-status-window 1 (cdr hl))
  41.     (window-set-attribute! pcs-status-window 'text-attributes at)
  42.     (gc)
  43.     *the-non-printing-object*))
  44.  
  45. ;    FULL-SCREEN makes the CONSOLE port as big as the video mode allows
  46.  
  47. (define (full-screen)
  48.   (window-set-position! 'console 0 0)
  49.   (window-set-size! 'console (car max-console) (cdr max-console))
  50.   (gc-screen))
  51.  
  52.  
  53. ;    SPLIT-SCREEN put the CONSOLE port to the last n lines of screen
  54.  
  55. (define (split-screen height)
  56.   (full-screen)
  57.   (window-set-position! 'console 
  58.             (- (car (window-get-size 'console)) height)
  59.             0)
  60.   (gc-screen))
  61.  
  62.  
  63. ;    TEXT-MODE change the video mode (same as Borland C/Turbo Pascal)
  64. ; Valid modes are :
  65. ; -------------------------------------------
  66. ;    -1    Previous mode
  67. ;    0    Black & White 40 columns
  68. ;    1    Color 40 columns
  69. ;    2    Black & White 80 columns
  70. ;    3    Color 80 columns
  71. ;    7    Monochrom
  72. ;    64    Ega 43 lines / Vga 50 lines
  73.  
  74. (define (text-mode mode)
  75.   (%esc 18 mode)
  76.   (full-screen))
  77.  
  78.  
  79. ;    WINDOW-SCROLL-UP and WINDOW-SCROLL-DOWN scroll a window 1 line
  80. ;    Optional parameters are: - first line to scroll
  81. ;                 - first line to stay (under scroll part)
  82. ;    (default values are 0 & number-of-lines)
  83.  
  84. (define window-scroll-up)
  85. (define window-scroll-down)
  86. (let ((window-scroll
  87.     (lambda (func)
  88.       (lambda (win . other)
  89.         (if (window? win)
  90.           (let* ((pos (window-get-position win))
  91.              (siz (window-get-size win))
  92.              (top (if (null? other) (car pos)
  93.                       (if (number? (car other))
  94.                 (+ (car pos) (car other))
  95.                 (%error-invalid-operand 'WINDOW-SCROLL (car other)))))
  96.              (big (- (car siz) (- top (car pos))))
  97.              (hei (if (null? (cdr other)) big
  98.                 (if (number? (cadr other))
  99.                 (min (- (cadr other) (car other)) big)
  100.                 (%error-invalid-operand 'WINDOW-SCROLL (cadr other))))))
  101.         (if (> hei 0)
  102.             (%esc func top (cdr pos) hei (cdr siz)
  103.               (window-get-attribute win 'TEXT-ATTRIBUTES))))
  104.           (%error-invalid-operand 'WINDOW-SCROLL win))))))
  105.   (set! window-scroll-up (window-scroll 4))    ; %esc 4
  106.   (set! window-scroll-down (window-scroll 5))    ; %esc 5
  107. )
  108.  
  109. ;   MAKE-WINDOW returns a "default" window object with the following
  110. ;   attributes:
  111. ;
  112. ;       Upper Left Hand Corner     = 0,0
  113. ;       Size (Lines, Columns)      = 25,80 or 30,80 (the entire screen)
  114. ;       Cursor Position          = 0,0
  115. ;       Text Color                  = White (on IBM, high intensity white)
  116. ;       Border Color (if bordered) = Green (on IBM, low intensity green)
  117. ;       Transcript Recording       = Enabled
  118.  
  119. (define make-window                    ; MAKE-WINDOW
  120.   (lambda args
  121.     (let ((label (car args))
  122.       (bordered? (cadr args)))
  123.       (if (or (null? label) (string? label))
  124.       (let ((window (%make-window label)))
  125.         (if bordered? (%reify-port! window 6 #b00001010))    ; green
  126.         window)
  127.       (begin
  128.         (%error-invalid-operand 'MAKE-WINDOW label)
  129.         '())))))
  130.  
  131.  
  132. ;   WINDOW-CLEAR erases the data portion of a window (writes blanks using
  133. ;    the current text attributes) and positions the cursor in position
  134. ;    0,0 (the upper left hand corner of the window).  If the window is
  135. ;    bordered, the border is re-drawn by this operation.  This operation
  136. ;    more properly may be considered a "window-initialize" operation.
  137.  
  138. (define window-clear                    ; WINDOW-CLEAR
  139.   (lambda (window)
  140.     (if (or (window? window) (null? window))
  141.         (%clear-window window)
  142.     (begin
  143.       (%error-invalid-operand 'WINDOW-CLEAR window)
  144.       '()))))
  145.  
  146.  
  147. ;   The "delete-window" function completely erases the area of the CRT which
  148. ;    is covered by a given window, including the borders.  This function
  149. ;    accomplishes the erasing of the borders by expanding the dimensions
  150. ;    of the window (temporarily) so that the borders are included in the
  151. ;    data portion of the window; setting the border attribute to "no
  152. ;    border"; and issuing a "%clear-window" operation to clear the text
  153. ;    portion of the (temporarily) expanded window.  After clearing the
  154. ;    window and border, the original attributes of the window are
  155. ;    restored.
  156. ;
  157. ;    Note:  when expanding the size of the window to account for the
  158. ;    right and bottom borders, this routine takes advantage of the fact
  159. ;    that %reify-port will not allow a window's boundaries to be set
  160. ;    to be larger than the physical device size.  Therefore, no check
  161. ;    is performed to see if the right and bottom borders are off the
  162. ;    screen.
  163.  
  164. (define window-delete                    ; DELETE-WINDOW
  165.   (lambda (window)
  166.     (if (or (window? window) (null? window))
  167.       (if (eqv? (%reify-port window 6) -1)
  168.       (%clear-window window) ; if not bordered, just do a %clear-window
  169.       (let ((ul-line (%reify-port window 2)) ; save current attributes
  170.         (ul-col  (%reify-port window 3)) ;  for later restoration
  171.         (n-lines (%reify-port window 4))
  172.         (n-cols  (%reify-port window 5))
  173.         (b-attrib (%reify-port window 6))
  174.         (t-lines '())
  175.         (t-cols '()))
  176.         (begin
  177.           (when (> ul-line 0)
  178.             (begin ; increase window size to include top border
  179.                (%reify-port! window 2 (-1+ ul-line))
  180.                (%reify-port! window 4 (1+ n-lines))))
  181.           (when (> ul-col 0)
  182.             (begin ; increase window size to include left border
  183.               (%reify-port! window 3 (-1+ ul-col))
  184.               (%reify-port! window 5 (1+ n-cols))))
  185.           (set! t-lines (%reify-port window 4)) ; get new window size
  186.           (set! t-cols (%reify-port window 5))
  187.           (%reify-port! window 4 (1+ t-lines)) ; include bottom border
  188.           (%reify-port! window 5 (1+ t-cols)) ; include right border
  189.           (%reify-port! window 6 -1)    ; indicate no border
  190.           (%clear-window window)
  191.           (%reify-port! window 2 ul-line) ; restore the original
  192.           (%reify-port! window 3 ul-col)  ;  attributes to the user's
  193.           (%reify-port! window 4 n-lines) ;  window
  194.           (%reify-port! window 5 n-cols)
  195.           (%reify-port! window 6 b-attrib))))
  196.       (begin
  197.         (%error-invalid-operand 'WINDOW-DELETE window)
  198.     '()))))
  199.  
  200.  
  201. ;   WINDOW-GET-POSITION conses the coordinates of the upper left hand
  202. ;    position of a window into a pair as:  (line . column)
  203.  
  204. (define window-get-position                ; WINDOW-GET-POSITION
  205.   (lambda (window)
  206.     (if (or (window? window) (null? window))
  207.     (cons (%reify-port window 2) (%reify-port window 3))
  208.     (begin
  209.       (%error-invalid-operand 'WINDOW-GET-POSITION window)
  210.       '()))))
  211.  
  212.  
  213. ;   WINDOW-GET-SIZE conses the number of lines and columns in a window
  214. ;    (excluding the border columns, if any) into a pair as:
  215. ;    (lines . columns)
  216.  
  217. (define window-get-size                    ; WINDOW-GET-SIZE
  218.   (lambda (window)
  219.     (if (or (window? window) (null? window))
  220.     (cons (%reify-port window 4) (%reify-port window 5))
  221.     (begin
  222.       (%error-invalid-operand 'WINDOW-GET-SIZE window)
  223.       '()))))
  224.  
  225.  
  226. ;   WINDOW-GET-CURSOR conses the line and column number of the current
  227. ;     cursor position into a pair as:  (line . column)
  228.  
  229. (define window-get-cursor                ; WINDOW-GET-CURSOR
  230.   (lambda (window)
  231.     (if (or (window? window) (null? window))
  232.     (cons (%reify-port window 0) (%reify-port window 1))
  233.     (begin
  234.       (%error-invalid-operand 'WINDOW-GET-CURSOR window)
  235.       '()))))
  236.  
  237.  
  238. ;   The following routines modify the position, size, and cursor position
  239. ;    of a window by side effecting the appropriate fields in a window
  240. ;    object.  An argument value of '() indicates that a particular
  241. ;    field's value is to remain unchanged.
  242.  
  243. (define window-set-position!)
  244. (define window-set-size!)
  245. (define window-set-cursor!)
  246. (letrec ((chk-and-set
  247.       (lambda (window line column instruction-name L C)
  248.         (cond
  249.          ((not (or (window? window) (null? window)))
  250.           (error (string-append "Invalid Window Argument to "
  251.                     (symbol->string instruction-name))
  252.              window))
  253.          ((and line
  254.            (or (not (integer? line))
  255.                (negative? line)))
  256.           (error (string-append "Invalid Line Number to "
  257.                     (symbol->string instruction-name))
  258.              line))
  259.          ((and column
  260.            (or (not (integer? column))
  261.                (negative? column)))
  262.           (error (string-append "Invalid Column Number to "
  263.                     (symbol->string instruction-name))
  264.              column))
  265.          (else
  266.           (when line (%reify-port! window L line))
  267.           (when column (%reify-port! window C column))
  268.           window)))))
  269.    (set! window-set-position!                ; WINDOW-SET-POSITION!
  270.      (lambda (window ul-line ul-col)
  271.        (chk-and-set window ul-line ul-col
  272.             'WINDOW-SET-POSITION! 2 3)))
  273.    (set! window-set-size!                ; WINDOW-SET-SIZE!
  274.      (lambda (window n-lines n-cols)
  275.        (chk-and-set window n-lines n-cols
  276.             'WINDOW-SET-SIZE! 4 5)))
  277.    (set! window-set-cursor!                ; WINDOW-SET-CURSOR!
  278.      (lambda (window cur-line cur-col)
  279.        (chk-and-set window cur-line cur-col
  280.             'WINDOW-SET-CURSOR! 0 1))))
  281.  
  282.  
  283. ;     Pop-Up window manipulation.
  284. ;
  285. ;     "WINDOW-POPUP" preserves the data on the screen which will be
  286. ;    covered by the pop-up window, initializes the window, and
  287. ;    returns the pop-up window object to the caller.
  288. ;
  289. ;     "WINDOW-POPUP-DELETE" restores the region of the CRT covered by a
  290. ;    window created "WINDOW-POPUP" to its state prior to the
  291. ;    pop-up window's appearance.
  292.  
  293. (define window-popup)
  294. (define window-popup-delete)
  295. (let ((pop-up-list '()))
  296.   (begin
  297.     (set! window-popup                    ; WINDOW-POPUP
  298.       (lambda (window)
  299.         (if (or (window? window) (null? window))
  300.       (begin
  301.         (set! pop-up-list
  302.           (cons (list window 
  303.               (window-save-contents window)
  304.               (window-get-cursor window)
  305.               (%reify-port window 6)
  306.               (%reify-port window 7)
  307.               (%reify-port window 8))
  308.             pop-up-list))
  309.         (window-delete window)
  310.         (%clear-window window)
  311.         window)
  312.       (begin
  313.         (%error-invalid-operand 'WINDOW-POPUP window)
  314.         '()))))
  315.     (set! window-popup-delete                ; WINDOW-POPUP-DELETE
  316.       (lambda (window)
  317.     (let* ((saved-data (assq window pop-up-list))
  318.            (reify-data (cdddr saved-data)))
  319.       (when (not (null? saved-data))
  320.         (window-restore-contents window (cadr saved-data))
  321.         (window-set-cursor! window (caaddr saved-data) (cdaddr saved-data))
  322.         (%reify-port! window 6 (car reify-data))
  323.         (%reify-port! window 7 (cadr reify-data))
  324.         (%reify-port! window 8 (caddr reify-data))
  325.         (set! pop-up-list (delq! saved-data pop-up-list))
  326.         window)))) ))
  327.  
  328.  
  329. ;   The following routines get and set window attributes which are not
  330. ;    modifiable by any of the above routines.  It is necessary to explicitly
  331. ;    name the attribute you wish to examine/modify.
  332.  
  333. (define window-get-attribute)
  334. (define window-set-attribute!)
  335. (letrec ((attr-list '((border-attributes . 6)
  336.              (text-attributes . 7)
  337.              (window-flags . 8)))
  338.      (check-and-map-args
  339.        (lambda (window attribute)
  340.          (if (or (window? window) (null? window))
  341.            (cdr (assq attribute attr-list))
  342.            #F))))
  343.   (set! window-get-attribute
  344.     (lambda (window attribute)
  345.       (let ((mapped-attribute (check-and-map-args window attribute)))
  346.     (if mapped-attribute
  347.         (%reify-port window mapped-attribute)
  348.         (begin
  349.           (%error-invalid-operand-list 'WINDOW-GET-ATTRIBUTE
  350.                        window attribute)
  351.           '())))))
  352.   (set! window-set-attribute!
  353.     (lambda (window attribute value)
  354.       (let ((mapped-attribute (check-and-map-args window attribute)))
  355.     (if (and mapped-attribute
  356.          (integer? value)
  357.          (< value 32767)
  358.          (>= value -32768))
  359.         (%reify-port! window mapped-attribute value)
  360.         (begin
  361.           (%error-invalid-operand-list 'WINDOW-SET-ATTRIBUTE!
  362.                        window attribute value)
  363.           '()))))))
  364.  
  365. ;    WINDOW-REVERSE-TEXT helps to turn text to reverse, ie swaps text
  366. ;    and background color of 'text-attributes
  367.  
  368. (define (window-reverse-text! win)
  369.   (if (window? win)
  370.       (window-set-attribute!
  371.     win
  372.     'text-attributes
  373.     (bitwise-xor (window-get-attribute win 'text-attributes)
  374.              #b01111111))
  375.       (%error-invalid-operand-list 'WINDOW-REVERSE-TEXT win)))
  376.  
  377.